home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / fonts.lisp < prev    next >
Lisp/Scheme  |  1992-04-30  |  13KB  |  367 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package :xlib)
  20.  
  21. ;; The char-info stuff is here instead of CLX because of uses of int16->card16.
  22.  
  23. ; To allow efficient storage representations, the type char-info is not
  24. ; required to be a structure.
  25.  
  26. ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
  27.  
  28. ;(defun char-<metric> (font index)
  29. ;  ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
  30. ;  ;; (or an in-bounds index on a pseudo font), although returning zero or
  31. ;  ;; signalling might be better.
  32. ;  (declare (type font font)
  33. ;       (type integer index)
  34. ;       (values (or null integer))))
  35.  
  36. ;(defun max-char-<metric> (font)
  37. ;  ;; Note: I have tentatively chosen separate accessors over allowing :min and
  38. ;  ;; :max as an index above.
  39. ;  (declare (type font font)
  40. ;       (values integer)))
  41.  
  42. ;(defun min-char-<metric> (font)
  43. ;  (declare (type font font)
  44. ;       (values integer)))
  45.  
  46. ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
  47.  
  48. (deftype char-info-vec () '(simple-array int16 (*)))
  49.  
  50. (macrolet ((def-char-info-accessors (useless-name &body fields)
  51.         `(within-definition (,useless-name def-char-info-accessors)
  52.            ,@(do ((field fields (cdr field))
  53.               (n 0 (1+ n))
  54.               (name) (type)
  55.               (result nil))
  56.              ((endp field) result)
  57.            (setq name (xintern 'char- (caar field)))
  58.            (setq type (cadar field))
  59.            (flet ((from (form)
  60.                 (if (eq type 'int16)
  61.                 form
  62.                 `(,(xintern 'int16-> type) ,form))))
  63.              (push
  64.                `(defun ,name (font index)
  65.               (declare (type font font)
  66.                    (type array-index index))
  67.               (declare (values (or null ,type)))
  68.               (when (and (font-name font)
  69.                      (index>= (font-max-char font) index (font-min-char font)))
  70.                 (the ,type
  71.                  ,(from
  72.                     `(the int16
  73.                       (let ((char-info-vector (font-char-infos font)))
  74.                         (declare (type char-info-vec char-info-vector))
  75.                         (if (index-zerop (length char-info-vector))
  76.                         ;; Fixed width font
  77.                         (aref (the char-info-vec
  78.                                (font-max-bounds font))
  79.                               ,n)
  80.                         ;; Variable width font
  81.                         (aref char-info-vector
  82.                               (index+
  83.                             (index*
  84.                               6
  85.                               (index-
  86.                                 index
  87.                                 (font-min-char font)))
  88.                             ,n)))))))))
  89.                result)
  90.              (setq name (xintern 'min-char- (caar field)))
  91.              (push
  92.                `(defun ,name (font)
  93.               (declare (type font font))
  94.               (declare (values (or null ,type)))
  95.               (when (font-name font)
  96.                 (the ,type
  97.                  ,(from
  98.                     `(the int16
  99.                       (aref (the char-info-vec (font-min-bounds font))
  100.                         ,n))))))
  101.                result)
  102.              (setq name (xintern 'max-char- (caar field)))
  103.              (push
  104.                `(defun ,name (font)
  105.               (declare (type font font))
  106.               (declare (values (or null ,type)))
  107.               (when (font-name font)
  108.                 (the ,type
  109.                  ,(from
  110.                     `(the int16
  111.                       (aref (the char-info-vec (font-max-bounds font))
  112.                         ,n))))))
  113.                result)))
  114.       
  115.            (defun make-char-info
  116.               (&key ,@(mapcar
  117.                 #'(lambda (field)
  118.                     `(,(car field) (required-arg ,(car field))))
  119.                 fields))
  120.          (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
  121.          (let ((result (make-array ,(length fields) :element-type 'int16)))
  122.            (declare (type char-info-vec result)
  123.                 (array-register result))
  124.            ,@(do* ((field fields (cdr field))
  125.                (var (caar field) (caar field))
  126.                (type (cadar field) (cadar field))
  127.                (n 0 (1+ n))
  128.                (result nil))
  129.               ((endp field) (nreverse result))
  130.                (push `(setf (aref result ,n)
  131.                     ,(if (eq type 'int16)
  132.                      var
  133.                      `(,(xintern type '->int16) ,var)))
  134.                  result))
  135.            result)))))
  136.   (def-char-info-accessors ignore
  137.     (left-bearing int16)
  138.     (right-bearing int16)
  139.     (width int16)
  140.     (ascent int16)
  141.     (descent int16)
  142.     (attributes card16)))
  143.     
  144. (defun open-font (display name)
  145.   ;; Font objects may be cached and reference counted locally within the display
  146.   ;; object.  This function might not execute a with-display if the font is cached.
  147.   ;; The protocol QueryFont request happens on-demand under the covers.
  148.   (declare (type display display)
  149.        (type stringable name))
  150.   (declare (values font))
  151.   (let* ((name-string (string-downcase (string name)))
  152.      (font (car (member name-string (display-font-cache display)
  153.                 :key 'font-name
  154.                 :test 'equal)))
  155.      font-id)
  156.     (unless font
  157.       (setq font (make-font :display display :name name-string))
  158.       (setq font-id (allocate-resource-id display font 'font))
  159.       (setf (font-id-internal font) font-id)
  160.       (with-buffer-request (display *x-openfont*)
  161.     (resource-id font-id)
  162.     (card16 (length name-string))
  163.     (pad16 nil)
  164.     (string name-string))
  165.       (push font (display-font-cache display)))
  166.     (incf (font-reference-count font))
  167.     font))
  168.  
  169. (defun open-font-internal (font)
  170.   ;; Called "under the covers" to open a font object
  171.   (declare (type font font))
  172.   (declare (values resource-id))
  173.   (let* ((name-string (font-name font))
  174.      (display (font-display font))
  175.      (id (allocate-resource-id display font 'font)))
  176.     (setf (font-id-internal font) id)
  177.     (with-buffer-request (display *x-openfont*)
  178.       (resource-id id)
  179.       (card16 (length name-string))
  180.       (pad16 nil)
  181.       (string name-string))
  182.     (push font (display-font-cache display))
  183.     (incf (font-reference-count font))
  184.     id))
  185.  
  186. (defun discard-font-info (font)
  187.   ;; Discards any state that can be re-obtained with QueryFont.  This is
  188.   ;; simply a performance hint for memory-limited systems.
  189.   (declare (type font font))
  190.   (setf (font-font-info-internal font) nil
  191.     (font-char-infos-internal font) nil))
  192.  
  193. (defun query-font (font)
  194.   ;; Internal function called by font and char info accessors
  195.   (declare (type font font))
  196.   (declare (values font-info))
  197.   (let ((display (font-display font))
  198.     font-id
  199.     font-info
  200.     props)
  201.     (setq font-id (font-id font)) ;; May issue an open-font request
  202.     (with-buffer-request-and-reply (display *x-queryfont* 60)
  203.      ((resource-id font-id))
  204.       (let* ((min-byte2 (card16-get 40))
  205.          (max-byte2 (card16-get 42))
  206.          (min-byte1 (card8-get 49))
  207.          (max-byte1 (card8-get 50))
  208.          (min-char  min-byte2)
  209.          (max-char  (index+ (index-ash max-byte1 8) max-byte2))
  210.          (nfont-props (card16-get 46))
  211.          (nchar-infos (index* (card32-get 56) 6))
  212.          (char-info (make-array nchar-infos :element-type 'int16)))
  213.     (setq font-info
  214.           (make-font-info
  215.         :direction (member8-get 48 :left-to-right :right-to-left)
  216.         :min-char min-char
  217.         :max-char max-char
  218.         :min-byte1 min-byte1
  219.         :max-byte1 max-byte1
  220.         :min-byte2 min-byte2
  221.         :max-byte2 max-byte2
  222.         :all-chars-exist-p (boolean-get 51)
  223.         :default-char (card16-get 44)
  224.         :ascent (int16-get 52)
  225.         :descent (int16-get 54)
  226.         :min-bounds (char-info-get 8)
  227.         :max-bounds (char-info-get 24)))
  228.     (setq props (sequence-get :length (index* 2 nfont-props) :format int32
  229.                   :result-type 'list :index 60))
  230.     (sequence-get :length nchar-infos :format int16 :data char-info
  231.               :index (index+ 60 (index* 2 nfont-props 4)))
  232.     (setf (font-char-infos-internal font) char-info)
  233.     (setf (font-font-info-internal font) font-info)))
  234.     ;; Replace atom id's with keywords in the plist
  235.     (do ((p props (cddr p)))
  236.     ((endp p))
  237.       (setf (car p) (atom-name display (car p))))
  238.     (setf (font-info-properties font-info) props)
  239.     font-info))
  240.  
  241. (defun close-font (font)
  242.   ;; This might not generate a protocol request if the font is reference
  243.   ;; counted locally.
  244.   (declare (type font font))
  245.   (when (and (not (plusp (decf (font-reference-count font))))
  246.          (font-id-internal font))
  247.     (let ((display (font-display font))
  248.       (id (font-id-internal font)))
  249.       (declare (type display display))
  250.       ;; Remove font from cache
  251.       (setf (display-font-cache display) (delete font (display-font-cache display)))
  252.       ;; Close the font
  253.       (with-buffer-request (display *x-closefont*)
  254.     (resource-id id)))))
  255.  
  256. (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
  257.   (declare (type display display)
  258.        (type string pattern)
  259.        (type card16 max-fonts)
  260.        (type t result-type)) ;; CL type
  261.   (declare (values (sequence string)))
  262.   (let ((string (string pattern)))
  263.     (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16))
  264.      ((card16 max-fonts (length string))
  265.       (string string))
  266.       (values
  267.     (read-sequence-string
  268.       buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))))
  269.  
  270. (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
  271.   ;; Note: Was called list-fonts-with-info.
  272.   ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
  273.   ;; no per-character metrics and no resource-ids.  These pseudo fonts will be
  274.   ;; converted (internally) to real fonts dynamically as needed, by issuing an
  275.   ;; OpenFont request.  However, the OpenFont might fail, in which case the
  276.   ;; invalid-font error can arise.
  277.   (declare (type display display)
  278.        (type string pattern)
  279.        (type card16 max-fonts)
  280.        (type t result-type)) ;; CL type
  281.   (declare (values (sequence font)))
  282.   (let ((string (string pattern))
  283.     (result nil))
  284.     (with-buffer-request-and-reply (display *x-listfontswithinfo* 60
  285.                         :sizes (8 16) :multiple-reply t)
  286.      ((card16 max-fonts (length string))
  287.       (string string))
  288.       (cond ((zerop (card8-get 1)) t)
  289.         (t
  290.     (let* ((name-len (card8-get 1))
  291.            (min-byte2 (card16-get 40))
  292.            (max-byte2 (card16-get 42))
  293.            (min-byte1 (card8-get 49))
  294.            (max-byte1 (card8-get 50))
  295.            (min-char  min-byte2)
  296.            (max-char  (index+ (index-ash max-byte1 8) max-byte2))
  297.            (nfont-props (card16-get 46))
  298.            (font
  299.          (make-font
  300.            :display display
  301.            :name nil
  302.            :font-info-internal
  303.            (make-font-info
  304.              :direction (member8-get 48 :left-to-right :right-to-left)
  305.              :min-char min-char
  306.              :max-char max-char
  307.              :min-byte1 min-byte1
  308.              :max-byte1 max-byte1
  309.              :min-byte2 min-byte2
  310.              :max-byte2 max-byte2
  311.              :all-chars-exist-p (boolean-get 51)
  312.              :default-char (card16-get 44)
  313.              :ascent (int16-get 52)
  314.              :descent (int16-get 54)
  315.              :min-bounds (char-info-get 8)
  316.              :max-bounds (char-info-get 24)
  317.              :properties (sequence-get :length (index* 2 nfont-props)
  318.                            :format int32
  319.                            :result-type 'list
  320.                            :index 60)))))
  321.       (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4))))
  322.       (push font result))
  323.     nil)))
  324.     ;; Replace atom id's with keywords in the plist
  325.     (dolist (font result)
  326.       (do ((p (font-properties font) (cddr p)))
  327.       ((endp p))
  328.     (setf (car p) (atom-name display (car p)))))
  329.     (coerce (nreverse result) result-type)))
  330.  
  331. (defun font-path (display &key (result-type 'list))
  332.   (declare (type display display)
  333.        (type t result-type)) ;; CL type
  334.   (declare (values (sequence (or string pathname))))
  335.   (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16))
  336.        ()
  337.     (values
  338.       (read-sequence-string
  339.     buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))
  340.  
  341. (defun set-font-path (display paths)
  342.   (declare (type display display)
  343.        (type sequence paths)) ;; (sequence (or string pathname))
  344.   (let ((path-length (length paths))
  345.     (request-length 8))
  346.     ;; Find the request length
  347.     (dotimes (i path-length)
  348.       (let* ((string (string (elt paths i)))
  349.          (len (length string)))
  350.     (incf request-length (1+ len))))
  351.     (with-buffer-request (display *x-setfontpath* :length request-length)
  352.       (length (ceiling request-length 4))
  353.       (card16 path-length)
  354.       (pad16 nil)
  355.       (progn
  356.     (incf buffer-boffset 8)
  357.     (dotimes (i path-length)
  358.       (let* ((string (string (elt paths i)))
  359.          (len (length string)))
  360.         (card8-put 0 len)
  361.         (string-put 1 string :appending t :header-length 1)
  362.         (incf buffer-boffset (1+ len))))
  363.     (setf (buffer-boffset display) (lround buffer-boffset)))))
  364.   paths)
  365.  
  366. (defsetf font-path set-font-path)
  367.